VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cBinaryFileStream"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "Binary File Stream"
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private fno As Long
Private ptr As Long, ptr2 As Long
Private n As Byte, b As Byte

Private bin(30) As Long

Private Sub Class_Initialize()
Dim i As Long
bin(0) = 1
For i = 1 To 30
 bin(i) = bin(i - 1) * 2
Next i
End Sub

Private Sub Class_Terminate()
CloseFile
End Sub

Public Function OpenFile(ByVal FileName As String) As Boolean
On Error GoTo a
CloseFile
fno = 128 + Int(128 * Rnd) 'xxpp
Open FileName For Binary As #fno
ptr = 1
ptr2 = 0
OpenFile = True
Exit Function
a:
CloseFile
OpenFile = False
End Function

Public Sub CloseFile()
If fno > 0 Then
 Close fno
 fno = 0
End If
End Sub

Friend Property Get FileNo() As Long
FileNo = fno
End Property

Public Property Get FileSize() As Long
FileSize = LOF(fno)
End Property

Public Function Read(Buffer() As Byte, ByVal Size As Long) As Long
If ptr > 0 And fno > 0 Then
 Get #fno, ptr, Buffer
 If ptr + Size > FileSize Then
  Read = FileSize - ptr + 1
  ptr = 0
 Else
  Read = Size
  ptr = ptr + Size
 End If
Else
 Read = 0
End If
End Function

Public Function GetBit() As Byte
If ptr2 = 0 Then
 Get #fno, ptr, b
 n = 1
End If
GetBit = (b And n) \ n
ptr2 = ptr2 + 1
If ptr2 = 8 Then
 ptr2 = 0
 ptr = ptr + 1
Else
 n = n + n
End If
End Function

Public Function GetBitEx(ByVal Length As Long) As Long
Dim n2 As Long
If ptr2 > 0 Then
 If 8 - ptr2 > Length Then
  GetBitEx = (b \ bin(ptr2)) And (bin(Length) - 1)
  ptr2 = ptr2 + Length
  n = bin(ptr2)
  Exit Function
 Else
  n2 = (b \ bin(ptr2)) And (bin(8 - ptr2) - 1)
  Length = Length + ptr2 - 8
  ptr2 = 8 - ptr2
  ptr = ptr + 1
 End If
End If
Do Until Length < 8
 Get #fno, ptr, b
 n2 = n2 Or (bin(ptr2) * b)
 ptr2 = ptr2 + 8
 Length = Length - 8
 ptr = ptr + 1
Loop
If Length > 0 Then
 Get #fno, ptr, b
 n2 = n2 Or (bin(ptr2) * (b And (bin(Length) - 1)))
End If
ptr2 = Length
n = bin(ptr2)
GetBitEx = n2
End Function

Public Sub PutBit(ByVal d As Byte)
If ptr2 = 0 Then
 n = 1
 b = 0
End If
If d > 0 Then b = b Or n
ptr2 = ptr2 + 1
If ptr2 = 8 Then
 ptr2 = 0
 Put #fno, ptr, b
 ptr = ptr + 1
Else
 n = n + n
End If
End Sub

Public Sub PutBitEx(ByVal d As Long, ByVal Length As Long)
Dim n2 As Long
If ptr2 > 0 Then
 If 8 - ptr2 > Length Then
  n2 = ((bin(Length) - 1) And d) * bin(ptr2)
  b = b Or n2
  ptr2 = ptr2 + Length
  n = bin(ptr2)
  Exit Sub
 Else
  n2 = ((bin(8 - ptr2) - 1) And d) * bin(ptr2)
  d = d \ bin(8 - ptr2)
  b = b Or n2
  Length = Length + ptr2 - 8
  ptr2 = 0
  Put #fno, ptr, b
  ptr = ptr + 1
 End If
End If
Do Until Length < 8
 b = d And &HFF&
 Put #fno, ptr, b
 d = d \ 256&
 Length = Length - 8
 ptr = ptr + 1
Loop
ptr2 = Length
n = bin(ptr2)
b = d And &HFF&
End Sub

Public Sub EndPutBit()
If ptr2 > 0 Then
 Put #fno, ptr, b
 ptr2 = 0
 ptr = ptr + 1
End If
End Sub

Public Property Get Pointer() As Long
Pointer = ptr
End Property

Public Property Let Pointer(l As Long)
ptr = l
ptr2 = 0
End Property

